home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / DATABASE.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  17KB  |  661 lines
  1. { Revision History
  2.   881026 - Cleaned up Group / Level access
  3.          - Troglodyte
  4. }
  5.   {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  6.  
  7.   unit database;
  8.  
  9.   Interface
  10.  
  11.   uses crt,gentypes,gensubs,subs1,subs2,overret1;
  12.  
  13.  Procedure datamenu;
  14.  
  15.    Implementation
  16.  
  17. Procedure datamenu;
  18.   Var curbase:baserec;
  19.     curbasenum:Integer;
  20.  
  21.   Procedure packentry(Var p:parsedentry;Var a:anystr);
  22.     Var cnt:Integer;
  23.     Begin
  24.       a:='';
  25.       For cnt:=1 To curbase.numcats Do
  26.         If Length(a)+Length(p[cnt])>254 Then Begin
  27.           WriteLn('Entry to big, truncated.');
  28.           exit
  29.         End Else a:=a+p[cnt]+#1
  30.     End;
  31.  
  32.   Procedure parseentry(Var oa:anystr;Var p:parsedentry);
  33.     Var d,cnt:Integer;
  34.       a:anystr;
  35.     Begin
  36.       a:=oa;
  37.       For cnt:=1 To curbase.numcats Do Begin
  38.         d:=Pos(#1,a);
  39.         If d=0
  40.         Then p[cnt]:=''
  41.         Else
  42.           Begin
  43.             p[cnt]:=Copy(a,1,d-1);
  44.             a:=Copy(a,d+1,255)
  45.           End
  46.       End
  47.     End;
  48.  
  49.   Procedure makenewbase;
  50.  
  51.     Function getnumber(r1,r2:Integer;txt:mstr):Integer;
  52.       Var t:Integer;
  53.       Begin
  54.         Repeat
  55.           writestr(txt+':');
  56.           t:=valu(Input);
  57.           If (t<r1) Or (t>r2) Then
  58.             WriteLn('Sorry, must be from ',r1,' to ',r2,'.')
  59.         Until (t>=r1) And (t<=r2);
  60.         getnumber:=t
  61.       End;
  62.  
  63.     Var n,cnt:Integer;
  64.       b:baserec;
  65.       p:parsedentry;
  66.     Begin
  67.       n:=FileSize(ddfile)+1;
  68.       writehdr('Create database number '+strr(n));
  69.       writestr('Database name:');
  70.       If Length(Input)=0 Then exit;
  71.       b.basename:=Input;
  72.       Writestr(^M'Conference number (Return=None) :*');
  73.       b.conference:=0;
  74.       b.conference:=valu(input);
  75.       if (b.conference>32) then b.conference:=0;
  76.       if (b.conference=0) then begin
  77.           writestr('Access level [1] :');
  78.           If Length(Input)=0
  79.           Then b.level:=1
  80.           Else b.level:=valu(Input);
  81.         end
  82.       else
  83.         b.level := maxint ;
  84.       b.numcats:=getnumber(1,maxcats,'Number of categories');
  85.       b.numents:=0;
  86.       For cnt:=1 To b.numcats Do Begin
  87.         writestr('Category #'+strr(cnt)+' name:');
  88.         If Length(Input)=0 Then exit;
  89.         p[cnt]:=Input
  90.       End;
  91.       curbase:=b;
  92.       packentry(p,b.catnames);
  93.       Seek(ddfile,n-1);
  94.       Write(ddfile,b);
  95.       WriteLn('Database created!');
  96.       writelog(7,2,b.basename);
  97.       curbase:=b;
  98.       curbasenum:=n
  99.     End;
  100.  
  101.   Function Hasaccess(X:baserec):Boolean;
  102.     Var cnt,a:Integer;
  103.       b,d:anystr;
  104.       e:Boolean;
  105.  
  106.     Begin
  107.       e:=False;
  108.       If (X.conference>0) Then
  109.         If (urec.confset[x.conference]>0) Then e:=True;
  110.         if (x.conference=0) then
  111.         if (ulvl>x.level) then e:=true;
  112.       hasaccess:=e;
  113.  
  114.     End;
  115.  
  116.   Procedure nobases;
  117.     Begin
  118.     close(ddfile);
  119.       Rewrite(ddfile); close(ddfile);
  120.       WriteLn('No databases exist!');
  121.       If Not issysop Then exit;
  122.       writestr('Create first database now? *');
  123.       If Not yes Then exit;
  124.       reset(ddfile);
  125.       makenewbase
  126.     End;
  127.  
  128.   Procedure openddfile;
  129.     Begin
  130.       Assign(ddfile,'DataDir');
  131.       Reset(ddfile);
  132.       If IOResult<>0
  133.       Then nobases
  134.       Else Begin
  135.         Reset(ddfile);
  136.         If FileSize(ddfile)=0 Then Begin
  137.           Close(ddfile);
  138.           nobases
  139.         End
  140.       End
  141.     End;
  142.  
  143.   Procedure writecurbase;
  144.     Begin
  145.       Seek(ddfile,curbasenum-1);
  146.       Write(ddfile,curbase)
  147.     End;
  148.  
  149.   Procedure readcurbase;
  150.     Begin
  151.       Seek(ddfile,curbasenum-1);
  152.       Read(ddfile,curbase)
  153.     End;
  154.  
  155.   Procedure openefile;
  156.     Var i:Integer;
  157.     Begin
  158.       readcurbase;
  159.       If isopen(efile) Then Close(efile);
  160.       i:=IOResult;
  161.       Assign(efile,'Database.'+strr(curbasenum));
  162.       Reset(efile);
  163.       If IOResult<>0 Then Rewrite(efile);
  164.       curbase.numents:=FileSize(efile);
  165.       writecurbase
  166.     End;
  167.  
  168.   Function getparsedentry(Var p:parsedentry):Boolean;
  169.     Var cnt:Integer;
  170.       pr:parsedentry;
  171.       nonblank:Boolean;
  172.     Begin
  173.       nonblank:=False;
  174.       parseentry(curbase.catnames,pr);
  175.       WriteLn('(*=',unam,')');
  176.       For cnt:=1 To curbase.numcats Do Begin
  177.         writestr(pr[cnt]+': &');
  178.         If Length(Input)>0 Then nonblank:=True;
  179.         If Input='*'
  180.         Then p[cnt]:=unam
  181.         Else p[cnt]:=Input
  182.       End;
  183.       getparsedentry:=nonblank
  184.     End;
  185.  
  186.   Function getentry(Var a:anystr):Boolean;
  187.     Var p:parsedentry;
  188.     Begin
  189.       getentry:=getparsedentry(p);
  190.       packentry(p,a)
  191.     End;
  192.  
  193.   Const shownumbers:Boolean=False;
  194.   Procedure showparsedentry(Var p:parsedentry);
  195.     Var cnt:Integer;
  196.       pr:parsedentry;
  197.     Begin
  198.       parseentry(curbase.catnames,pr);
  199.       For cnt:=1 To curbase.numcats Do Begin
  200.         If shownumbers Then Write(cnt,'. ');
  201.         WriteLn(pr[cnt],': '^S,p[cnt]);
  202.         If break Then exit
  203.       End;
  204.       shownumbers:=False
  205.     End;
  206.  
  207.   Procedure showentry(Var a:anystr);
  208.     Var p:parsedentry;
  209.     Begin
  210.       parseentry(a,p);
  211.       showparsedentry(p)
  212.     End;
  213.  
  214.   Procedure showentrynum(Var a:anystr;num:Integer);
  215.     Begin
  216.       WriteLn(^M,num,':');
  217.       showentry(a)
  218.     End;
  219.  
  220.   Function noentries:Boolean;
  221.     Begin
  222.       If curbase.numents>0
  223.       Then noentries:=False
  224.       Else
  225.         Begin
  226.           WriteLn('Sorry, database is empty!');
  227.           noentries:=True
  228.         End
  229.     End;
  230.  
  231.   Procedure changeentryrec(Var e:entryrec);
  232.     Var p:parsedentry;
  233.       c:Integer;
  234.       done:Boolean;
  235.     Begin
  236.       parseentry(e.data,p);
  237.       Repeat
  238.         shownumbers:=True;
  239.         showparsedentry(p);
  240.         writestr(^M'Category number to change [CR to exit]:');
  241.         done:=Length(Input)=0;
  242.         If Not done Then Begin
  243.           c:=valu(Input);
  244.           If (c>0) And (c<=curbase.numcats) Then Begin
  245.             writestr('New value [*=Your name, CR to leave unchanged]: &');
  246.             If Length(Input)<>0 Then
  247.               If Input='*'
  248.               Then p[c]:=unam
  249.               Else p[c]:=Input
  250.           End
  251.         End
  252.       Until done;
  253.       packentry(p,e.data)
  254.     End;
  255.  
  256.   Procedure adddata;
  257.     Var e:entryrec;
  258.     Begin
  259.       writehdr('Add an entry');
  260.       If Not getentry(e.data) Then Begin
  261.         WriteLn('Blank entry!');
  262.         exit
  263.       End;
  264.       writestr(^M'Make changes (Y/N/X)? *');
  265.       If Length(Input)<>0 Then
  266.         Case UpCase(Input[1]) Of
  267.           'X' :Begin
  268.                  writestr('Entry not added.');
  269.                  exit
  270.                End;
  271.           'Y' :changeentryrec(e)
  272.         End;
  273.       e.when:=now;
  274.       e.addedby:=unum;
  275.       Seek(efile,curbase.numents);
  276.       Write(efile,e);
  277.       curbase.numents:=curbase.numents+1;
  278.       writecurbase
  279.     End;
  280.  
  281.   Procedure listdata;
  282.     Var cnt,f,l:Integer;
  283.       e:entryrec;
  284.     Begin
  285.       If noentries Then exit;
  286.       WriteLn;
  287.       parserange(curbase.numents,f,l);
  288.       If f=0 Then exit;
  289.       WriteLn;
  290.       For cnt:=f To l Do Begin
  291.         Seek(efile,cnt-1);
  292.         Read(efile,e);
  293.         showentrynum(e.data,cnt);
  294.         If break Then exit
  295.       End
  296.     End;
  297.  
  298.   Function getdatanum(txt:mstr):Integer;
  299.     Var n:Integer;
  300.     Begin
  301.       getdatanum:=0;
  302.       If noentries Then exit;
  303.       Repeat
  304.         writestr(^M'Entry to '+txt+' [?=list]:');
  305.         If Length(Input)=0 Then exit;
  306.         If Input='?' Then Begin
  307.           listdata;
  308.           Input:=''
  309.         End
  310.       Until Length(Input)>0;
  311.       n:=valu(Input);
  312.       If (n>0) And (n<=curbase.numents) Then getdatanum:=n
  313.     End;
  314.  
  315.   Function notuseradded(Var e:entryrec):Boolean;
  316.     Var b:Boolean;
  317.     Begin
  318.       b:=Not((e.addedby=unum) Or issysop);
  319.       notuseradded:=b;
  320.       If b Then writestr('You didn''t add this entry!')
  321.     End;
  322.  
  323.   Procedure changedata;
  324.     Var n:Integer;
  325.       e:entryrec;
  326.     Begin
  327.       n:=getdatanum('change');
  328.       If n=0 Then exit;
  329.       Seek(efile,n-1);
  330.       Read(efile,e);
  331.       If notuseradded(e) Then exit;
  332.       writelog(8,3,Copy(e.data,1,Pos(#1,e.data)-1));
  333.       changeentryrec(e);
  334.       Seek(efile,n-1);
  335.       Write(efile,e);
  336.     End;
  337.  
  338.   Procedure deletedata;
  339.     Var n,cnt:Integer;
  340.       e:entryrec;
  341.       p:parsedentry;
  342.     Begin
  343.       n:=getdatanum('delete');
  344.       If n=0 Then exit;
  345.       Seek(efile,n-1);
  346.       Read(efile,e);
  347.       If notuseradded(e) Then exit;
  348.       parseentry(e.data,p);
  349.       writelog(8,6,p[1]);
  350.       curbase.numents:=curbase.numents-1;
  351.       writecurbase;
  352.       For cnt:=n To curbase.numents Do Begin
  353.         Seek(efile,cnt);
  354.         Read(efile,e);
  355.         Seek(efile,cnt-1);
  356.         Write(efile,e)
  357.       End;
  358.       Seek(efile,curbase.numents);
  359.       Truncate(efile)
  360.     End;
  361.  
  362.   Procedure listbases;
  363.     Var cnt:Integer;
  364.       b:baserec;
  365.     Begin
  366.       writehdr('List of Databases');
  367.       If break Then exit;
  368.       For cnt:=1 To FileSize(ddfile) Do Begin
  369.         Seek(ddfile,cnt-1);
  370.         Read(ddfile,b);
  371.         If hasaccess(b) Then WriteLn(cnt,'. ',b.basename);
  372.         If break Then exit
  373.       End
  374.     End;
  375.  
  376.   Procedure selectdata;
  377.     Var n:Integer;
  378.       b:baserec;
  379.     Begin
  380.       If Length(Input)>1 Then Input:=Copy(Input,2,255) Else
  381.         Repeat
  382.           writestr('Database number [?=list]:');
  383.           If Length(Input)=0 Then exit;
  384.           If Input='?' Then Begin
  385.             listbases;
  386.             Input:=''
  387.           End
  388.         Until Length(Input)>0;
  389.       n:=valu(Input);
  390.       If (n<1) Or (n>FileSize(ddfile)) Then Begin
  391.         WriteLn('No such database: '^S,n);
  392.         If Not issysop Then exit;
  393.         n:=FileSize(ddfile)+1;
  394.         writestr('Create database #'+strr(n)+'? *');
  395.         If yes Then Begin
  396.           writecurbase;
  397.           makenewbase;
  398.           openefile
  399.         End;
  400.         exit
  401.       End;
  402.       Seek(ddfile,n-1);
  403.       Read(ddfile,b);
  404.       If Not hasaccess(b) Then Begin
  405.         reqlevel(b.level);
  406.         exit
  407.       End;
  408.       writecurbase;
  409.       curbasenum:=n;
  410.       openefile
  411.     End;
  412.  
  413.   Procedure searchdata;
  414.     Var cnt,f,en:Integer;
  415.       e:entryrec;
  416.       Pattern:anystr;
  417.       p:parsedentry;
  418.     Begin
  419.       If noentries Then exit;
  420.       writestr('Search pattern:');
  421.       If Length(Input)=0 Then exit;
  422.       Pattern:=Input;
  423.       For cnt:=1 To Length(Pattern) Do Pattern[cnt]:=UpCase(Pattern[cnt]);
  424.       For en:=1 To curbase.numents Do Begin
  425.         Seek(efile,en-1);
  426.         Read(efile,e);
  427.         parseentry(e.data,p);
  428.         For f:=1 To curbase.numcats Do Begin
  429.           For cnt:=1 To Length(p[f]) Do p[f][cnt]:=UpCase(p[f][cnt]);
  430.           If Pos(Pattern,p[f])<>0 Then showentrynum(e.data,en)
  431.         End
  432.       End;
  433.       WriteLn(^M'Search complete')
  434.     End;
  435.  
  436.   Const beenaborted:Boolean=False;
  437.  
  438.   Function aborted:Boolean;
  439.     Begin
  440.       If beenaborted Then Begin
  441.         aborted:=True;
  442.         exit
  443.       End;
  444.       aborted:=xpressed Or hungupon;
  445.       If xpressed Then Begin
  446.         beenaborted:=True;
  447.         WriteLn(^B'Newscan aborted!')
  448.       End
  449.     End;
  450.  
  451.   Procedure newscan;
  452.     Var first,cnt:Integer;
  453.       nd:Boolean;
  454.       e:entryrec;
  455.     Begin
  456.       beenaborted:=False;
  457.       first:=curbase.numents;
  458.       nd:=True;
  459.       While (first>0) And nd Do Begin
  460.         Seek(efile,first-1);
  461.         Read(efile,e);
  462.         nd:=e.when>laston;
  463.         If nd Then first:=first-1
  464.       End;
  465.       For cnt:=first+1 To curbase.numents Do Begin
  466.         Seek(efile,cnt-1);
  467.         Read(efile,e);
  468.         If aborted Then exit;
  469.         showentrynum(e.data,cnt)
  470.       End
  471.     End;
  472.  
  473.   Procedure newscanall;
  474.     Begin
  475.       writehdr('New-scanning... Press [X] to abort.');
  476.       curbasenum:=1;
  477.       While curbasenum<=FileSize(ddfile) Do Begin
  478.         If aborted Then exit;
  479.         openefile;
  480.         If hasaccess(curbase) Then Begin
  481.           WriteLn(^B^M'Scanning ',curbase.basename,^M);
  482.           newscan;
  483.           If aborted Then exit
  484.         End;
  485.         curbasenum:=curbasenum+1
  486.       End;
  487.       curbasenum:=1;
  488.       openefile;
  489.       WriteLn(^B'Newscan complete!')
  490.     End;
  491.  
  492.   Procedure killdatabase;
  493.     Var b:baserec;
  494.       cnt:Integer;
  495.     Begin
  496.       writestr('Kill database:  Are you sure? *');
  497.       If Not yes Then exit;
  498.       writecurbase;
  499.       Close(efile);
  500.       Erase(efile);
  501.       For cnt:=curbasenum To FileSize(ddfile)-1 Do Begin
  502.         Seek(ddfile,cnt);
  503.         Read(ddfile,b);
  504.         Seek(ddfile,cnt-1);
  505.         Write(ddfile,b);
  506.         Assign(efile,'Database.'+strr(cnt+1));
  507.         Rename(efile,'Database.'+strr(cnt))
  508.       End;
  509.       Seek(ddfile,FileSize(ddfile)-1);
  510.       Truncate(ddfile);
  511.       writelog(8,5,'');
  512.       If FileSize(ddfile)>0 Then Begin
  513.         curbasenum:=1;
  514.         openefile
  515.       End
  516.     End;
  517.  
  518.   Procedure reorderdata;
  519.     Var numd,curd,newd:Integer;
  520.       b1,b2:baserec;
  521.       f1,f2:File;
  522.       fn1,fn2:sstr;
  523.     Label exit;
  524.     Begin
  525.       writecurbase;
  526.       writehdr('Re-order databases');
  527.       writelog(8,1,'');
  528.       numd:=FileSize(ddfile);
  529.       WriteLn('Number of database: ',numd);
  530.       For curd:=0 To numd-2 Do Begin
  531.         Repeat
  532.           writestr('New database #'+strr(curd+1)+' [?=List, CR to quit]:');
  533.           If Length(Input)=0 Then GoTo exit;
  534.           If Input='?'
  535.           Then
  536.             Begin
  537.               listbases;
  538.               newd:=-1
  539.             End
  540.           Else
  541.             Begin
  542.               newd:=valu(Input)-1;
  543.               If (newd<0) Or (newd>=numd) Then Begin
  544.                 WriteLn('Not found!  Please re-enter...');
  545.                 newd:=-1
  546.               End
  547.             End
  548.         Until (newd>0);
  549.         Seek(ddfile,curd);
  550.         Read(ddfile,b1);
  551.         Seek(ddfile,newd);
  552.         Read(ddfile,b2);
  553.         Seek(ddfile,curd);
  554.         Write(ddfile,b2);
  555.         Seek(ddfile,newd);
  556.         Write(ddfile,b1);
  557.         fn1:='Database.';
  558.         fn2:=fn1+strr(newd+1);
  559.         fn1:=fn1+strr(curd+1);
  560.         Assign(f1,fn1);
  561.         Assign(f2,fn2);
  562.         Rename(f1,'Temp$$$$');
  563.         Rename(f2,fn1);
  564.         Rename(f1,fn2)
  565.       End;
  566. exit: 
  567.       curbasenum:=1;
  568.       openefile
  569.     End;
  570.  
  571.   Procedure renamedata;
  572.     Begin
  573.       WriteLn('Current name: '^S,curbase.basename);
  574.       writestr('Enter new name:');
  575.       If Length(Input)>0 Then Begin
  576.         curbase.basename:=Input;
  577.         writecurbase;
  578.         writelog(8,2,Input)
  579.       End
  580.     End;
  581.  
  582.   Procedure setlevel;
  583.     Begin
  584.           writeln('Current Conference: '^S,curbase.conference);
  585.           writestr('Enter New Conference:');
  586.           if length(input)<>0 then curbase.conference:=valu(input);
  587.           if (curbase.conference>32) then curbase.conference:=0;
  588.           WriteLn('Current level: '^S,curbase.level);
  589.           writestr('Enter new level:');
  590.           If Length(Input)<>0 Then
  591.             curbase.level:=valu(Input)
  592.       else
  593.         curbase.level := maxint ;
  594.       Writestr ( 'Save changes [N,y]:' ) ;
  595.       if length(input) = 0 then exit ;
  596.       if upcase(input[1]) = 'Y' then
  597.         begin
  598.           writecurbase;
  599.           writelog(8,4,strr(curbase.level))
  600.         end ;
  601.     End;
  602.  
  603.   Procedure sysopcommands;
  604.     Var q:Integer;
  605.     Begin
  606.       writelog(7,1,curbase.basename);
  607.       Repeat
  608.         q:=menu('Database Sysop','DSYSOP','QCDEKOR');
  609.         Case q Of
  610.           2:changedata;
  611.           3:deletedata;
  612.           4:setlevel;
  613.           5:killdatabase;
  614.           6:reorderdata;
  615.           7:renamedata
  616.         End
  617.       Until (q=1) Or hungupon Or (FileSize(ddfile)=0)
  618.     End;
  619.  
  620.   Var q:Integer;
  621.   Begin
  622.     cursection:=databasesysop;
  623.     openddfile;
  624.     If FileSize(ddfile)=0 Then begin
  625.      close(ddfile);
  626.      exit end;
  627.     curbasenum:=1;
  628.     Seek(ddfile,0);
  629.     Read(ddfile,curbase);
  630.     If Not hasaccess(curbase) Then Begin
  631.       reqlevel(curbase.level);
  632.       Close(ddfile);
  633.       exit
  634.     End;
  635.     openefile;
  636.  
  637.     Writehdr('The Database Section');
  638.     Repeat
  639.       WriteLn(^B^M'Current Database:  '^S,curbase.basename);
  640.       WriteLn('# of records: '^S,curbase.numents,^M);
  641.       q:=menu('Database','DATA','QA*SLVNH%@CD');
  642.       Case q Of
  643.         2:adddata;
  644.         3:selectdata;
  645.         4:searchdata;
  646.         5:listdata;
  647.         6:newscan;
  648.         7:newscanall;
  649.         8:help('Database.hlp');
  650.         9:sysopcommands;
  651.         10:changedata;
  652.         11:deletedata
  653.       End
  654.     Until hungupon Or (q=1) Or (FileSize(ddfile)=0);
  655.     Close(ddfile);
  656.     Close(efile)
  657.   End;
  658.  
  659. Begin
  660. End.
  661.